home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / scroller.lisp < prev    next >
Text File  |  1991-07-15  |  52KB  |  1,346 lines
  1. ;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Fonts:(CPTFONT); Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21.  
  22.  
  23. (in-package "CLIO-OPEN")
  24.  
  25. (export '(
  26.       make-scroller
  27.       scale-increment
  28.       scale-indicator-size
  29.       scale-maximum
  30.       scale-minimum
  31.       scale-orientation
  32.       scale-update
  33.       scale-update-delay
  34.       scale-value
  35.       scroller
  36.       )
  37.     'clio-open)
  38.  
  39.  
  40. ;;;----------------------------------------------------------------------------+
  41. ;;;                                                                            |
  42. ;;;                             Scroller                                       |
  43. ;;;                                                                            |
  44. ;;;----------------------------------------------------------------------------+
  45.  
  46.  
  47. ;; Implementation Strategy:
  48. ;;
  49. ;; Elevator and anchor controls are implemented as non-contact subwindows (i.e.
  50. ;; scroller is NOT a composite). Overall, this strategy simplifies the tasks
  51. ;; of determining which control is receiving input and of confining the pointer
  52. ;; cursor to controls during continuous scrolling, without unnecessarily
  53. ;; incurring the full cost of a sub-contact.
  54.  
  55. ;; The elevator is represented as an :input-output subwindow; the imagery of all
  56. ;; elevator controls is drawn to this subwindow.  The less/more arrow and drag
  57. ;; area controls are represented as :input-only subwindows of the elevator
  58. ;; subwindow. Subwindows are used for these controls only for use as :confine-to
  59. ;; windows while the pointer is grabbed.
  60.  
  61. ;; All control subwindows are recorded in the regions vector of the scroller.
  62. ;; The scroller subwindow receiving a :button-press is determined from the child
  63. ;; slot of the button event.  During event handling, the regions vector is
  64. ;; searched to look up the vector index of the event window (see FIND-REGION).
  65. ;; If the event child is the elevator, then a further search based on elevator
  66. ;; geometry is necessary to determine which elevator subwindow is the event
  67. ;; window.  The resulting vector index is used to select an element from a
  68. ;; vector of functions to handle the :button-press (see PRESS-HANDLERS).
  69.  
  70.  
  71. (defcontact scroller (core contact)  
  72.   ((increment     :type         number
  73.          :reader         scale-increment           ; setf defined below
  74.         :initarg    :increment
  75.          :initform     1)
  76.    
  77.    (indicator-size
  78.                 :type         (or number (member :off))
  79.         :reader         scale-indicator-size   ; setf defined below
  80.         :initarg    :indicator-size
  81.         :initform     0)
  82.    
  83.    (maximum     :type         number
  84.          :reader         scale-maximum           ; setf defined below
  85.         :initarg    :maximum
  86.          :initform     1)
  87.    
  88.    (minimum     :type         number
  89.          :reader         scale-minimum           ; setf defined below
  90.         :initarg    :minimum
  91.          :initform     0)
  92.    
  93.    (orientation :type         (member :horizontal :vertical)
  94.          :reader         scale-orientation      ; setf defined below
  95.         :initarg    :orientation
  96.          :initform     :vertical)
  97.    
  98.    (update-delay :type        (or number (member :until-done))
  99.          :reader         scale-update-delay    ; setf defined below
  100.          :initarg    :update-delay
  101.          :initform    0)
  102.    
  103.    (value     :type         number
  104.          :reader         scale-value           ; setf defined below
  105.         :initarg    :value
  106.          :initform     0)
  107.    
  108.    (compress-exposures 
  109.                 :initform       :on
  110.         :type           (member :off :on)
  111.         :reader         contact-compress-exposures
  112.         :allocation     :class)
  113.  
  114.    (regions     :type           (vector window)
  115.         :initform       (make-array 6)))
  116.   
  117.   (:resources
  118.     increment indicator-size maximum minimum orientation update-delay value
  119.     (border-width :initform 0)
  120.     (event-mask   :initform #.(make-event-mask :pointer-motion-hint :exposure))))
  121.  
  122.  
  123. ;; Index values for accessing region vector and press handler vector
  124. (defconstant *elevator-region*   0)
  125. (defconstant *min-anchor-region* 1)
  126. (defconstant *max-anchor-region* 2)
  127. (defconstant *less-arrow-region* 3)
  128. (defconstant *drag-area-region*  4)
  129. (defconstant *more-arrow-region* 5)
  130. (defconstant *cable-region*      6)
  131.  
  132.  
  133. ;;;----------------------------------------------------------------------------+
  134. ;;;                                                                            |
  135. ;;;                            Initialization                                  |
  136. ;;;                                                                            |
  137. ;;;----------------------------------------------------------------------------+
  138.  
  139. (defun make-scroller (&rest initargs &key &allow-other-keys)
  140.   (apply #'make-contact 'scroller initargs))
  141.  
  142.  
  143. (defmethod initialize-instance :after ((self scroller) &key &allow-other-keys)
  144.   (with-slots (width height) self
  145.     ;; Initialize required geometry
  146.     (multiple-value-setq (width height) (preferred-size self))))
  147.  
  148. (defun min-anchor-geometry (dimensions scroller orientation width height)
  149.   (declare (ignore scroller))
  150.   (let ((anchor-width  (scrollbar-anchor-width dimensions))
  151.     (anchor-height (scrollbar-anchor-height dimensions)))
  152.     (if (eq orientation :vertical)
  153.     (values (pixel-round (- width anchor-width) 2) 0 (- anchor-width 2) (- anchor-height 2))
  154.     (values 0 (pixel-round (- height anchor-width) 2) (- anchor-height 2) (- anchor-width 2)))))
  155.    
  156. (defun max-anchor-geometry (dimensions scroller orientation width height)
  157.   (declare (ignore scroller))
  158.   (let ((anchor-width  (scrollbar-anchor-width dimensions))
  159.     (anchor-height (scrollbar-anchor-height dimensions)))
  160.     (if (eq orientation :vertical)
  161.     (values (pixel-round (- width anchor-width) 2) (- height anchor-height) (- anchor-width 2) (- anchor-height 2))
  162.     (values (- width anchor-height) (pixel-round (- height anchor-width) 2) (- anchor-height 2) (- anchor-width 2)))))
  163.    
  164. (defun elevator-geometry (dimensions scroller orientation width height) 
  165.   (let ((anchor-width  (scrollbar-anchor-width dimensions)))
  166.     (if (eq orientation :vertical)
  167.     (values (pixel-round (- width anchor-width) 2) (scroller-value-position scroller) anchor-width (scrollbar-elevator-size scroller))
  168.     (values (scroller-value-position scroller) (pixel-round (- height anchor-width) 2) (scrollbar-elevator-size scroller) anchor-width))))
  169.    
  170. (defun less-arrow-geometry (dimensions scroller orientation width height)
  171.   (declare (ignore scroller orientation width height))
  172.   (let ((anchor-width  (scrollbar-anchor-width dimensions)))
  173.     (values 0 0 anchor-width anchor-width)))
  174.    
  175. (defun more-arrow-geometry (dimensions scroller orientation width height)
  176.   (declare (ignore width height))
  177.   (let ((anchor-width  (scrollbar-anchor-width dimensions))
  178.     (abbreviated-p (scrollbar-abbreviated-p scroller)))
  179.     (if (eq orientation :vertical)
  180.     (values 0 (+ anchor-width (if abbreviated-p 0 anchor-width)) anchor-width anchor-width)
  181.     (values (+ anchor-width (if abbreviated-p 0 anchor-width)) 0 anchor-width anchor-width))))
  182.    
  183. (defun drag-area-geometry (dimensions scroller orientation width height)
  184.   (declare (ignore scroller width height))
  185.   (let ((anchor-width  (scrollbar-anchor-width dimensions)))
  186.     (if (eq orientation :vertical)
  187.     (values 0 anchor-width anchor-width anchor-width)
  188.     (values anchor-width 0 anchor-width anchor-width))))
  189.    
  190. (defmethod reconfigure-controls ((self scroller))
  191.   (declare (type scroller self))
  192.   (with-slots (regions width height orientation)
  193.     self                ;(the scroller self) 
  194.     (let ((dimensions (getf *scrollbar-dimensions* (contact-scale self)))) 
  195.       (let ((window (svref regions *min-anchor-region*)))
  196.     (with-state (window)
  197.       (multiple-value-bind (window-x window-y window-width window-height)
  198.           (min-anchor-geometry dimensions self orientation width height)
  199.         (setf (drawable-x window)      window-x
  200.           (drawable-y window)      window-y
  201.           (drawable-width window)  window-width
  202.           (drawable-height window) window-height))))
  203.       (let ((window (svref regions *max-anchor-region*)))
  204.     (with-state (window)
  205.       (multiple-value-bind (window-x window-y window-width window-height)
  206.           (max-anchor-geometry dimensions self orientation width height)
  207.         (setf (drawable-x window)      window-x
  208.           (drawable-y window)      window-y
  209.           (drawable-width window)  window-width
  210.           (drawable-height window) window-height))))
  211.       (let ((window (svref regions *elevator-region*)))
  212.     (with-state (window)
  213.       (multiple-value-bind (window-x window-y window-width window-height)
  214.           (elevator-geometry dimensions self orientation width height)
  215.         (setf (drawable-x window)      window-x
  216.           (drawable-y window)      window-y
  217.           (drawable-width window)  window-width
  218.           (drawable-height window) window-height))))
  219.       (let ((window (svref regions *drag-area-region*)))
  220.     (with-state (window)
  221.       (multiple-value-bind (window-x window-y window-width window-height)
  222.           (drag-area-geometry dimensions self orientation width height)
  223.         (setf (drawable-x window)      window-x
  224.           (drawable-y window)      window-y
  225.           (drawable-width window)  window-width
  226.           (drawable-height window) window-height))))
  227.       (let ((window (svref regions *less-arrow-region*)))
  228.     (with-state (window)
  229.       (multiple-value-bind (window-x window-y window-width window-height)
  230.           (less-arrow-geometry dimensions self orientation width height)
  231.         (setf (drawable-x window)      window-x
  232.           (drawable-y window)      window-y
  233.           (drawable-width window)  window-width
  234.           (drawable-height window) window-height))))
  235.       (let ((window (svref regions *more-arrow-region*)))
  236.     (with-state (window)
  237.       (multiple-value-bind (window-x window-y window-width window-height)
  238.           (more-arrow-geometry dimensions self orientation width height)
  239.         (setf (drawable-x window)      window-x
  240.           (drawable-y window)      window-y
  241.           (drawable-width window)  window-width
  242.           (drawable-height window) window-height)))))))
  243.  
  244. (defmethod realize :after ((self scroller))
  245.   ;; Create control region windows
  246.   (with-slots (regions width height orientation foreground)
  247.     self
  248.     (let* ((dimensions    (getf *scrollbar-dimensions* (contact-scale self))) 
  249.      
  250.        (min-anchor    (multiple-value-bind (region-x region-y region-width region-height)
  251.                   (min-anchor-geometry dimensions self orientation width height)
  252.                 (create-window
  253.                  :parent self
  254.                  :x      region-x
  255.                  :y      region-y
  256.                  :width  region-width
  257.                  :height region-height
  258.                  :background :parent-relative
  259.                  :border-width 1
  260.                  :border foreground
  261.                  :gravity (if (eq orientation :vertical) :north :west))))
  262.      
  263.        (max-anchor    (multiple-value-bind (region-x region-y region-width region-height)
  264.                   (max-anchor-geometry dimensions self orientation width height)
  265.                 (create-window
  266.                  :parent self
  267.                  :x      region-x
  268.                  :y      region-y
  269.                  :width  region-width
  270.                  :height region-height
  271.                  :background :parent-relative
  272.                  :border-width 1
  273.                  :border foreground
  274.                  :gravity (if (eq orientation :vertical) :north :west))))
  275.      
  276.        (elevator      (multiple-value-bind (region-x region-y region-width region-height)
  277.                   (elevator-geometry dimensions self orientation width height)
  278.                 (create-window
  279.                  :parent self
  280.                  :x      region-x
  281.                  :y      region-y
  282.                  :width  region-width
  283.                  :height region-height
  284.                  :border-width 0
  285.                  :gravity (if (eq orientation :vertical) :north :west))))
  286.      
  287.        (drag-area     (multiple-value-bind (region-x region-y region-width region-height)
  288.                   (drag-area-geometry dimensions self orientation width height)
  289.                 (create-window
  290.                  :parent elevator
  291.                  :class  :input-only
  292.                  :x      region-x
  293.                  :y      region-y
  294.                  :width  region-width
  295.                  :height region-height
  296.                  :border-width 0)))
  297.      
  298.        (less-arrow    (multiple-value-bind (region-x region-y region-width region-height)
  299.                   (less-arrow-geometry dimensions self orientation width height)
  300.                 (create-window
  301.                  :parent elevator
  302.                  :class  :input-only
  303.                  :x      region-x
  304.                  :y      region-y
  305.                  :width  region-width
  306.                  :height region-height
  307.                  :border-width 0)))
  308.      
  309.        (more-arrow    (multiple-value-bind (region-x region-y region-width region-height)
  310.                   (more-arrow-geometry dimensions self orientation width height)
  311.                 (create-window
  312.                  :parent elevator
  313.                  :class  :input-only
  314.                  :x      region-x
  315.                  :y      region-y
  316.                  :width  region-width
  317.                  :height region-height
  318.                  :border-width 0))))
  319.     
  320.       (setf (svref regions *min-anchor-region*) min-anchor)
  321.       (setf (svref regions *max-anchor-region*) max-anchor)
  322.       (setf (svref regions *elevator-region*)   elevator)
  323.       (setf (svref regions *drag-area-region*)  drag-area)
  324.       (setf (svref regions *less-arrow-region*) less-arrow)
  325.       (setf (svref regions *more-arrow-region*) more-arrow)
  326.     
  327.       (map-subwindows self)
  328.       (map-subwindows elevator))))
  329.  
  330. (defmethod rescale ((self scroller))
  331.   (with-slots (orientation) 
  332.     self
  333.     ;; Request change to preferred width/height, depending on orientation.
  334.     (multiple-value-bind (rw rh) (if (eq :vertical orientation) (values 0 nil) (values nil 0))
  335.       (multiple-value-bind (pw ph) (preferred-size self :width rw :height rh)
  336.     (change-geometry self :width pw :height ph :accept-p t))))
  337.     
  338.   (when (realized-p self)
  339.     (reconfigure-controls self)))
  340.  
  341. (defmethod (setf scale-orientation) (new-orientation (scroller scroller))
  342.   (with-slots (orientation width height)
  343.     scroller
  344.     (unless (eq orientation new-orientation)
  345.       (check-type new-orientation (member :horizontal :vertical))
  346.     
  347.       (setf orientation new-orientation)
  348.     
  349.       (multiple-value-bind (new-width new-height)
  350.       (preferred-size scroller :width height :height width)
  351.     (change-geometry scroller :width new-width :height new-height))
  352.       (reconfigure-controls scroller)))
  353.     
  354.   new-orientation)
  355.  
  356.  
  357. ;;;----------------------------------------------------------------------------+
  358. ;;;                                                                            |
  359. ;;;                              Accessors                                     |
  360. ;;;                                                                            |
  361. ;;;----------------------------------------------------------------------------+
  362.  
  363.  
  364. (defmethod (setf scale-update-delay) (new-update-delay (scroller scroller))
  365.   (with-slots (update-delay) scroller
  366.     (assert (or (eq new-update-delay :until-done)
  367.         (and (numberp new-update-delay) (not (minusp new-update-delay)))) ()
  368.         "~a is neither :UNTIL-DONE or a non-negative number." new-update-delay)    
  369.     (setf update-delay new-update-delay)))
  370.  
  371. (defmethod (setf scale-value) (new-value (scroller scroller))
  372.   (scale-update scroller :value new-value)
  373.   new-value)
  374.     
  375. (defmethod (setf scale-minimum) (new-minimum (scroller scroller))
  376.   (scale-update scroller :minimum new-minimum)
  377.   new-minimum)
  378.  
  379. (defmethod (setf scale-maximum) (new-maximum (scroller scroller))
  380.   (scale-update scroller :maximum new-maximum)
  381.   new-maximum)
  382.  
  383. (defmethod (setf scale-increment) (new-increment (scroller scroller))
  384.   (scale-update scroller :increment new-increment)
  385.   new-increment)
  386.  
  387. (defmethod (setf scale-indicator-size) (new-indicator-size (scroller scroller))
  388.   (scale-update scroller :indicator-size new-indicator-size)
  389.   new-indicator-size)
  390.  
  391. (defmacro true-indicator-size (size)
  392.   `(if (eq ,size :off) 0 ,size))
  393.  
  394. (defmethod scale-update ((scroller scroller) &key value minimum maximum indicator-size increment)
  395.   (with-slots
  396.     ((current-val value)
  397.      (current-min minimum)
  398.      (current-max maximum)
  399.      (current-ind indicator-size)
  400.      (current-inc increment)
  401.      regions
  402.      orientation)
  403.     scroller
  404.     
  405.     
  406.     (setf minimum        (or minimum current-min)
  407.       maximum        (or maximum current-max)
  408.       value          (or value current-val)
  409.       indicator-size (or indicator-size current-ind)
  410.       increment      (or increment current-inc))
  411.  
  412.     (assert (numberp value) () "~s for :value is not a number" value)
  413.     (assert (numberp minimum) () "~s for :minimum is not a number" minimum)
  414.     (assert (numberp maximum) () "~s for :maximum is not a number" maximum)
  415.     (assert (and (numberp increment) (not (minusp increment))) ()
  416.       "~s for :increment is not a number" increment)
  417.     (assert (or (and (numberp indicator-size) (not (minusp indicator-size)))
  418.         (eq indicator-size :off))
  419.       () "~s for :indicator-size is not :off or a non-negative-number)" indicator-size)
  420.  
  421.  
  422.     (assert (<= minimum maximum) ()
  423.         "Minimum (~a) is greater than maximum (~a)."
  424.         minimum maximum)
  425.     (assert (<= minimum value maximum) ()
  426.         "Value (~a) must be in the range [~a, ~a]."
  427.          value minimum maximum)
  428.  
  429.     (let*
  430.       ((insensitive-p    (not (sensitive-p scroller)))
  431.        (less-arrow-dim-p (or insensitive-p (= current-val current-min)))
  432.        (more-arrow-dim-p (or insensitive-p (= current-val current-max)))
  433.        (prev-min         current-min)
  434.        (prev-max         current-max)
  435.        (prev-ind         current-ind)
  436.        (prev-val         current-val))
  437.       
  438.       (setf current-min minimum
  439.         current-max maximum
  440.         current-val value
  441.         current-ind indicator-size
  442.         current-inc increment)
  443.       
  444.       ;; Update display
  445.       (when (realized-p scroller)
  446.     (cond
  447.       ((not (and (eql current-min prev-min) (eql current-max prev-max) (eql current-ind prev-ind)))
  448.        (display scroller))
  449.  
  450.       ((not (eql current-val prev-val))
  451.        
  452.        ;; Position elevator
  453.        (let ((position (scroller-value-position scroller))
  454.          (elevator (svref regions *elevator-region*)))
  455.          (if (eq :vertical orientation)
  456.          (setf (drawable-y elevator) position)
  457.          (setf (drawable-x elevator) position)))
  458.        
  459.        ;; Dim arrows, if necessary
  460.        (scrollbar-update-less-arrow scroller less-arrow-dim-p insensitive-p)
  461.        (scrollbar-update-more-arrow scroller more-arrow-dim-p insensitive-p)))))))
  462.  
  463. (defmethod (setf contact-foreground) :after (new-fg (self scroller))
  464.   (declare (ignore new-fg))
  465.   (with-slots (foreground regions) self
  466.     (setf (window-border (svref regions *min-anchor-region*)) foreground)
  467.     (setf (window-border (svref regions *max-anchor-region*)) foreground)))
  468.  
  469.  
  470.  
  471. ;;;----------------------------------------------------------------------------+
  472. ;;;                                                                            |
  473. ;;;                        Geometry Management                                 |
  474. ;;;                                                                            |
  475. ;;;----------------------------------------------------------------------------+
  476.  
  477.  
  478. (defmethod preferred-size ((self scroller) &key width height border-width)
  479.   (declare (ignore border-width))
  480.   (with-slots (orientation (current-height height) (current-width width)) self
  481.     (let*
  482.       ((dimensions       (getf *scrollbar-dimensions* (contact-scale self))) 
  483.        (margin           (scrollbar-margin dimensions))
  484.        (anchor-width     (scrollbar-anchor-width dimensions))
  485.        (anchor-height    (scrollbar-anchor-height dimensions))
  486.  
  487.        ;; Calculate geometry assuming :vertical orientation
  488.        (preferred-width  (+ margin anchor-width margin))
  489.        (preferred-height (max
  490.                ;; Suggested or current height
  491.                (or (if (eq orientation :vertical) height width)
  492.                    (if (eq orientation :vertical) current-height current-width))
  493.                
  494.                ;; Size of abbreviated scrollbar (no drag area)
  495.                (+ anchor-height margin
  496.                   anchor-width  anchor-width
  497.                   margin anchor-height))))
  498.  
  499.       ;; Return preferred geometry according to actual orientation
  500.       (values
  501.     (if (eq orientation :vertical) preferred-width  preferred-height)
  502.     (if (eq orientation :vertical) preferred-height preferred-width)
  503.     0))))
  504.  
  505. (defmethod resize :around ((self scroller) new-width new-height new-border-width)
  506.   (if (realized-p self)
  507.       ;; Reconfigure subwindows
  508.       (let* ((abbreviated-before-p (scrollbar-abbreviated-p self))
  509.          (resized-p            (call-next-method)))
  510.     (with-slots (width height orientation regions) self
  511.       (let*
  512.         ((scale             (contact-scale self))
  513.          (max-anchor        (svref regions *max-anchor-region*))
  514.          (dimensions        (getf *scrollbar-dimensions* scale))
  515.          (anchor-position   (- (if (eq orientation :vertical) height width)
  516.                    (scrollbar-anchor-height dimensions)
  517.                    1))
  518.          (elevator          (svref regions *elevator-region*))
  519.          (elevator-position (scroller-value-position self)))
  520.         
  521.         ;; Reposition max anchor
  522.         (if (eq orientation :vertical)
  523.         (setf (drawable-y max-anchor) anchor-position)
  524.         (setf (drawable-x max-anchor) anchor-position))
  525.         
  526.         ;; Reconfigure elevator
  527.         (multiple-value-bind (elevator-size abbreviated-after-p)
  528.         (scrollbar-elevator-size self)
  529.           (with-state (elevator)
  530.         (case orientation
  531.           (:vertical          
  532.            (setf (drawable-y elevator)      elevator-position)
  533.            (setf (drawable-height elevator) elevator-size))
  534.           
  535.           (:horizontal
  536.            (setf (drawable-x elevator)      elevator-position)
  537.            (setf (drawable-width elevator)  elevator-size))))
  538.           
  539.           ;; Changing abbreviation?
  540.           (unless (eq abbreviated-before-p abbreviated-after-p)
  541.         ;; Reposition more-arrow region
  542.         (let* ((anchor-width   (scrollbar-anchor-width dimensions))
  543.                (more-arrow-pos (+ anchor-width (if abbreviated-after-p 0 anchor-width))))
  544.           (if (eq orientation :vertical)
  545.               (setf (drawable-y (svref regions *more-arrow-region*)) more-arrow-pos)
  546.               (setf (drawable-x (svref regions *more-arrow-region*)) more-arrow-pos)))
  547.         
  548.         ;; Redisplay elevator image
  549.         (scrollbar-display-elevator self scale)))))
  550.     resized-p)
  551.       
  552.       ;; If not yet realized, just do it
  553.       (call-next-method)))
  554.     
  555.  
  556.  
  557. (defun scrollbar-abbreviated-p (scroller)
  558.   (with-slots (width height orientation) (the scroller scroller)
  559.     (let*
  560.       ((dimensions       (getf *scrollbar-dimensions* (contact-scale scroller))) 
  561.        (margin           (scrollbar-margin dimensions))
  562.        (anchor-width     (scrollbar-anchor-width dimensions))
  563.        (anchor-height    (scrollbar-anchor-height dimensions)))
  564.  
  565.       (<= (if (eq orientation :vertical) height width)
  566.       
  567.       (+ anchor-height margin
  568.          anchor-width anchor-width anchor-width
  569.          margin anchor-height)))))
  570.  
  571.  
  572. (defun scrollbar-elevator-size (scroller)
  573.   (let ((abbreviated-p (scrollbar-abbreviated-p scroller)))
  574.     (values
  575.       (+ (* (scrollbar-anchor-width
  576.           (getf *scrollbar-dimensions* (contact-scale scroller)))
  577.         (if abbreviated-p  2 3))
  578.      2)
  579.       abbreviated-p)))
  580.  
  581. (defun scrollbar-less-arrow-geometry (scroller)
  582.   (let ((arrow-size (1- (scrollbar-anchor-width (getf *scrollbar-dimensions*
  583.                               (contact-scale scroller))))))
  584.     (if (eq :vertical (scale-orientation scroller))
  585.     (values 1 1 (- arrow-size 2) arrow-size)
  586.     (values 1 1 arrow-size (- arrow-size 2)))))
  587.  
  588. (defun scrollbar-drag-area-geometry (scroller)
  589.   (let*
  590.     ((area-size      (scrollbar-anchor-width
  591.             (getf *scrollbar-dimensions* (contact-scale scroller))))
  592.      (area-position  (1+ area-size)))
  593.  
  594.     (if (eq :vertical (scale-orientation scroller))
  595.     (values 1 area-position (- area-size 3) (1- area-size))
  596.     (values area-position 1 (1- area-size) (- area-size 3)))))
  597.  
  598. (defun scrollbar-more-arrow-geometry (scroller)
  599.   (let*
  600.     ((arrow-size      (scrollbar-anchor-width
  601.             (getf *scrollbar-dimensions* (contact-scale scroller))))
  602.      (arrow-position  (1+ (+ arrow-size (if (scrollbar-abbreviated-p scroller) 0 arrow-size)))))
  603.  
  604.     (if (eq :vertical (scale-orientation scroller))
  605.     (values 1 arrow-position (- arrow-size 3) (1- arrow-size))
  606.     (values arrow-position 1 (1- arrow-size) (- arrow-size 3)))))
  607.  
  608.  
  609.  
  610. ;;;----------------------------------------------------------------------------+
  611. ;;;                                                                            |
  612. ;;;                               Display                                      |
  613. ;;;                                                                            |
  614. ;;;----------------------------------------------------------------------------+
  615.  
  616. (defmethod display ((self scroller) &optional at-x at-y at-width at-height &key)  
  617.   (with-slots (width height foreground regions orientation) self
  618.     ;; Default exposed rectangle, if necessary
  619.     (setf at-x      (or at-x      0)
  620.       at-y      (or at-y      0)
  621.       at-width  (or at-width  (- width at-x))
  622.       at-height (or at-height (- height at-y)))
  623.     (let*
  624.       ((scale             (contact-scale self))
  625.        (dimensions        (getf *scrollbar-dimensions* scale))
  626.        (anchor-width      (scrollbar-anchor-width dimensions))
  627.        (anchor-height     (scrollbar-anchor-height dimensions))
  628.        (margin            (scrollbar-margin dimensions))
  629.        (cable-margin      (scrollbar-cable-margin dimensions))
  630.        (cable-width       (scrollbar-cable-width dimensions))
  631.        (elevator-position (scroller-value-position self))
  632.        (elevator-size     (scrollbar-elevator-size self))
  633.        (elevator-end      (+ elevator-position elevator-size)))
  634.  
  635.       ;;-----------------------------------------------------------------------------+
  636.       ;;                                                                             |
  637.       ;; Draw cable.                                                                 |
  638.       ;;                                                                             |
  639.       ;; Stipple fill  is  relatively  slow,  so  redrawing  entire cable can cause  |
  640.       ;; annoying flicker.   But  computing  the  minimal  cable  area to redraw is  |
  641.       ;; complicated, because the display  method is expected  to update the  image  |
  642.       ;; when the elevator  moves (thus  exposing a  small region  of the  scroller  |
  643.       ;; previously obscured by the  elevator).  In this  case, we must  redraw the  |
  644.       ;; cable not only in  the area exposed,  but also elsewhere  to cover up  the  |
  645.       ;; previous gaps between elevator/proportion indicator/cable.                  |
  646.       ;;                                                                             |
  647.       ;; The following algorithm is a compromise.  If the exposed area is  entirely  |
  648.       ;; on one side of the  elevator (as it is  in the case of  an elevator move),  |
  649.       ;; then we redraw the cable only on that side.                                 |
  650.       ;;                                                                             | 
  651.       ;;-----------------------------------------------------------------------------+
  652.  
  653.       (flet
  654.      ((exposed-cable-segment
  655.        (exposed-position exposed-size scroller-size)
  656.        (let ((min (+ anchor-height margin))
  657.          (max (- scroller-size margin anchor-height)))
  658.          (cond
  659.            ;; Exposed area before elevator?
  660.            ((>= elevator-position (+ exposed-position exposed-size))
  661.         ;; Redraw only first part of cable.
  662.         (values min (- elevator-position min)))
  663.            
  664.            ;; Exposed area behind elevator?
  665.            ((>= exposed-position elevator-end)
  666.         ;; Redraw only last part of cable.
  667.         (values elevator-end (- max elevator-end)))
  668.            
  669.            (t
  670.         ;; Redraw all of cable.
  671.         (values min (- max min)))))))
  672.        
  673.       (multiple-value-bind (cable-x cable-y cable-width cable-height)
  674.       (if (eq orientation :vertical)
  675.           (multiple-value-bind (cy ch) (exposed-cable-segment at-y at-height height)
  676.         (values (pixel-round (- width cable-width) 2) cy cable-width ch))
  677.  
  678.           (multiple-value-bind (cx cw) (exposed-cable-segment at-x at-width width)
  679.           (values cx (pixel-round (- height cable-width) 2) cw cable-width)))
  680.  
  681.     ;; Draw exposed cable area
  682.     (using-gcontext (gc :drawable self
  683.                 :fill-style :stippled
  684.                 :foreground foreground
  685.                 :stipple    (contact-image-mask self 50%gray :depth 1))
  686.       (clear-area self :x cable-x :y cable-y :width cable-width :height cable-height)
  687.       (draw-rectangle self gc cable-x cable-y cable-width cable-height :fill-p))
  688.  
  689.     ;; Draw proportion indicator
  690.     (let* ((pi-size (scroller-indicator-size self))
  691.            (pi-pos  (scroller-indicator-position self pi-size)))
  692.       (multiple-value-bind (pi-x pi-y pi-width pi-height margin-x margin-y margin-width margin-height)
  693.           (if (eq orientation :vertical)
  694.           (values
  695.             cable-x
  696.             pi-pos
  697.             cable-width
  698.             pi-size
  699.  
  700.             cable-x
  701.             (- pi-pos margin)
  702.             cable-width
  703.             (+ pi-size margin margin))
  704.           (values
  705.             pi-pos
  706.             cable-y
  707.             pi-size
  708.             cable-height
  709.  
  710.             (- pi-pos margin)
  711.             cable-y
  712.             (+ pi-size margin margin)
  713.             cable-height))
  714.         (clear-area self :x margin-x :y margin-y :width margin-width :height margin-height)
  715.         (using-gcontext (gc :drawable self
  716.                 :fill-style :solid
  717.                 :foreground foreground)
  718.           (draw-rectangle self gc pi-x pi-y pi-width pi-height :fill-p))))))
  719.       
  720.       ;; Clear cable margin around elevator
  721.       (multiple-value-bind (gap-x gap-y gap-width gap-height)
  722.       (if (eq orientation :vertical)
  723.           (values
  724.         0 (- elevator-position cable-margin)
  725.         nil (+ cable-margin elevator-size cable-margin))
  726.           (values
  727.         (- elevator-position cable-margin) 0
  728.         (+ cable-margin elevator-size cable-margin) nil))
  729.     (clear-area self :x gap-x :y gap-y :width gap-width :height gap-height))
  730.       
  731.       ;; Compute elevator geometry
  732.       (multiple-value-bind (elevator-x elevator-y elevator-width elevator-height)
  733.       (if (eq orientation :vertical)
  734.           (values
  735.         (scrollbar-margin dimensions)
  736.         elevator-position
  737.         anchor-width
  738.         elevator-size)
  739.           (values
  740.         elevator-position
  741.         (scrollbar-margin dimensions)                
  742.         elevator-size
  743.         anchor-width))    
  744.     (when
  745.       ;; Exposed area intersects elevator?
  746.       (and (< elevator-x (+ at-x at-width))
  747.            (< elevator-y (+ at-y at-height))
  748.            (> (+ elevator-x elevator-width) at-x)
  749.            (> (+ elevator-y elevator-height) at-y))
  750.  
  751.       (scrollbar-display-elevator self scale))))))
  752.  
  753.  
  754.  
  755. (defun scrollbar-display-elevator (scroller &optional scale)
  756.   (setf scale (or scale (contact-scale scroller)))
  757.   
  758.   (with-slots (orientation regions foreground) (the scroller scroller)
  759.     ;; Draw elevator image
  760.     (let*
  761.       ((image    (getf (getf *scrollbar-images* orientation) scale))
  762.        (mask     (contact-image-mask
  763.            scroller image
  764.            :foreground foreground
  765.            :background (contact-current-background-pixel scroller)))
  766.        (elevator (svref regions *elevator-region*)))
  767.       
  768.       (using-gcontext (gc :drawable scroller :exposures :off)
  769.     (copy-area
  770.       mask gc
  771.       0 0
  772.       (image-width image) (image-height image)
  773.       elevator
  774.       0 0)
  775.     
  776.     (when (scrollbar-abbreviated-p scroller)
  777.       (let ((copy-size (scrollbar-anchor-width (getf *scrollbar-dimensions* scale))))
  778.         
  779.         (multiple-value-bind (from-x from-y copy-width copy-height)
  780.         (if (eq :vertical orientation)
  781.             (values 0 (+ copy-size copy-size) copy-size (+ copy-size 2))
  782.             (values (+ copy-size copy-size) 0 (+ copy-size 2) copy-size))
  783.           
  784.           (multiple-value-bind (to-x to-y)
  785.           (if (eq :vertical orientation)
  786.               (values 0 copy-size)
  787.               (values copy-size 0))
  788.         
  789.         (copy-area
  790.           mask gc
  791.           from-x from-y
  792.           copy-width copy-height          
  793.           elevator
  794.           to-x to-y))))))))
  795.   
  796.   ;; Dim arrows, if necessary
  797.   (let ((insensitive-p (not (sensitive-p scroller))))
  798.     (scrollbar-update-less-arrow scroller nil insensitive-p)
  799.     (scrollbar-update-more-arrow scroller nil insensitive-p)))
  800.  
  801.  
  802.  
  803. (defun scrollbar-update-less-arrow (scroller dim-p insensitive-p)
  804.   (with-slots (value minimum foreground regions) (the scroller scroller)
  805.     (unless (eq dim-p (or insensitive-p (= value minimum)))
  806.  
  807.       (multiple-value-bind (arrow-x arrow-y arrow-width arrow-height)
  808.       (scrollbar-less-arrow-geometry scroller)
  809.     
  810.     (using-gcontext
  811.       (gc :drawable   scroller
  812.           :function   boole-xor
  813.           :fill-style :stippled
  814.           :foreground (logxor foreground (contact-current-background-pixel scroller))
  815.           :stipple    (contact-image-mask scroller 25%gray :depth 1))
  816.       
  817.       (draw-rectangle
  818.         (svref regions *elevator-region*) gc
  819.         arrow-x arrow-y
  820.         arrow-width arrow-height
  821.         :fill-p))))))
  822.  
  823.  
  824. (defun scrollbar-update-more-arrow (scroller dim-p insensitive-p)
  825.   (with-slots (value maximum foreground regions) (the scroller scroller)
  826.     (unless (eq dim-p (or insensitive-p (= value maximum)))
  827.  
  828.       (multiple-value-bind (arrow-x arrow-y arrow-width arrow-height)
  829.       (scrollbar-more-arrow-geometry scroller)
  830.     
  831.     (using-gcontext
  832.       (gc :drawable   scroller
  833.           :function   boole-xor
  834.           :fill-style :stippled
  835.           :foreground (logxor foreground (contact-current-background-pixel scroller))
  836.           :stipple    (contact-image-mask scroller 25%gray :depth 1))
  837.           
  838.       (draw-rectangle
  839.         (svref regions *elevator-region*) gc
  840.         arrow-x arrow-y
  841.         arrow-width arrow-height
  842.         :fill-p))))))
  843.  
  844.  
  845. ;;;----------------------------------------------------------------------------+
  846. ;;;                                                                            |
  847. ;;;                          Event Translations                                |
  848. ;;;                                                                            |
  849. ;;;----------------------------------------------------------------------------+
  850.  
  851. (defevent scroller (:motion-notify :button-1)  scroller-handle-motion)
  852. (defevent scroller (:timer :update-delay)      scroller-report-new-value)
  853. (defevent scroller (:timer :click)             (throw-action :click-timeout))
  854. (defevent scroller (:button-release :button-1) scroller-handle-release)
  855. (defevent scroller (:button-press :button-1)   scroller-handle-press)
  856.  
  857. (defparameter *scroller-click-timeout* 0.2
  858.   "Number of seconds to wait before starting continuous scrolling")
  859.  
  860. (defparameter *scroller-hold-timeout* 0.05
  861.   "Number of seconds to wait during continuous scrolling before updating value")
  862.  
  863. (let ((press-handlers (make-array 7)))
  864.   (flet
  865.     ((find-region (scroller)
  866.       ;; Return index of scroller region containing the current event
  867.       (with-slots (regions orientation) scroller
  868.     (with-event (child x y)
  869.       (if child
  870.           
  871.           ;; Look up event child window among scroller regions
  872.           (let ((region (position child regions :test #'eq)))
  873.         
  874.         (if (= region *elevator-region*)
  875.             ;; Which part of elevator got the press: less-arrow, drag-area, or more-arrow?
  876.             (let
  877.               ((region (+ *less-arrow-region*
  878.                   (floor
  879.                     (- (if (eq :vertical orientation) y x)
  880.                        (scroller-value-position scroller))
  881.                     (scrollbar-anchor-width
  882.                       (getf *scrollbar-dimensions*
  883.                              (contact-scale scroller)))))))
  884.               (if (and (= region *drag-area-region*)
  885.                    (scrollbar-abbreviated-p scroller))
  886.               *more-arrow-region*
  887.               region))
  888.             
  889.             ;; Min/max anchor press
  890.             region))
  891.           
  892.           ;; Event occurred on non-child area of scroller
  893.           *cable-region*))))
  894.     
  895.     (press-cable (scroller)
  896.       (with-slots (orientation increment width height indicator-size update-delay display value) scroller
  897.     (with-event (x y)
  898.       (multiple-value-bind (event-position max-position)
  899.           (if (eq :vertical orientation) (values y height) (values x width))
  900.         (let*
  901.           ((anchor-height  (scrollbar-anchor-height
  902.                  (getf *scrollbar-dimensions* (contact-scale scroller))))
  903.            (min-position   anchor-height)
  904.            (max-position   (- max-position anchor-height))
  905.            (pane-size      (let ((size (true-indicator-size indicator-size)))
  906.                  (if (plusp size) size increment)))
  907.            (pane-increment (if (< event-position (scroller-value-position scroller))
  908.                    ;; Decrement by pane?
  909.                    (when (>= event-position min-position)
  910.                      (- pane-size))
  911.                    
  912.                    ;; Increment by pane?
  913.                    (when (<= event-position max-position)
  914.                      pane-size))))
  915.           (unless pane-increment
  916.         ;; Just wait for release and do nothing
  917.         (catch :release (loop (process-next-event display)))
  918.         (return-from press-cable))
  919.  
  920.         
  921.           (if (catch :release
  922.              ;; If user is clicking fast on cable, then we can arrive here
  923.              ;; before all :exposure's from previous clicks have been processed.
  924.              ;; Therefore, must use a timer, so we can continue processing :exposure's
  925.              ;; while waiting for click release.
  926.              (add-timer scroller :click *scroller-click-timeout*)
  927.              (unwind-protect
  928.              (catch :click-timeout
  929.                (loop (process-next-event display)))
  930.                (delete-timer scroller :click))
  931.              t)
  932.  
  933.             ;; Perform continuous pane scrolling...
  934.             (let ((current-x x) (current-y y))
  935.               ;; Set timer for update
  936.               (when (and (numberp update-delay) (plusp update-delay))
  937.             (add-timer scroller :update-delay update-delay))
  938.               
  939.               ;; Increment and warp pointer as needed, until release event
  940.               (apply-callback scroller :begin-continuous)
  941.               (catch :release          
  942.             (loop
  943.               (scroller-increment-value scroller pane-increment)
  944.               (multiple-value-setq (current-x current-y)
  945.                 (scrollbar-cable-warp
  946.                   scroller pane-increment
  947.                   current-x current-y
  948.                   min-position max-position))
  949.               
  950.               ;; Wait for timeout to elapse
  951.               (do () ((not (process-next-event display *scroller-hold-timeout*))))))
  952.               (apply-callback scroller :end-continuous))
  953.         
  954.             ;; Single click -- increment value
  955.             (progn
  956.               (scroller-increment-value scroller pane-increment)
  957.               
  958.               ;; Warp pointer to keep it between elevator and anchor
  959.               (scrollbar-cable-warp
  960.             scroller pane-increment
  961.             x y
  962.             min-position max-position)))
  963.           
  964.         ;; Report final value, if necessary                       
  965.         (unless (eql 0 update-delay)
  966.           (delete-timer scroller :update-delay)
  967.           (apply-callback scroller :new-value value)))))))
  968.  
  969.     (press-drag-area (scroller)
  970.       (with-slots (display regions value update-delay foreground orientation) scroller
  971.     (let
  972.       ((highlight-pixel (logxor foreground (contact-current-background-pixel scroller)))
  973.        (elevator        (svref regions *elevator-region*)))
  974.       
  975.       (multiple-value-bind (drag-x drag-y drag-width drag-height)
  976.           (scrollbar-drag-area-geometry scroller)
  977.         
  978.         (using-gcontext
  979.           (gc :drawable       scroller
  980.           :function       boole-xor
  981.           :foreground     highlight-pixel)
  982.           
  983.           ;; Highlight drag area
  984.           (draw-rectangle
  985.         elevator gc
  986.         drag-x drag-y drag-width drag-height :fill-p)
  987.  
  988.           (with-event (x y)
  989.         (let ((*previous-position* (if (eq :vertical orientation) y x))
  990.               (*drag-motion*       t))
  991.           (declare (special *previous-position* *drag-motion*))
  992.           
  993.           ;; Set timer for update
  994.           (when (and (numberp update-delay) (plusp update-delay))
  995.             (add-timer scroller :update-delay update-delay))
  996.  
  997.           ;; Handle motion events until release.
  998.           (catch :release
  999.             (loop (process-next-event display))))) 
  1000.           
  1001.           ;; Report final value.
  1002.           (when (and (numberp update-delay) (plusp update-delay))
  1003.         (delete-timer scroller :update-delay))
  1004.           (apply-callback scroller :new-value value)
  1005.  
  1006.           ;; Unhighlight drag area
  1007.           (draw-rectangle
  1008.         elevator gc
  1009.         drag-x drag-y drag-width drag-height :fill-p))))))
  1010.     
  1011.     (press-less-arrow (scroller)
  1012.       (with-slots (display regions value maximum increment update-delay foreground orientation) scroller
  1013.     (let
  1014.       ((highlight-pixel (logxor foreground (contact-current-background-pixel scroller))))
  1015.  
  1016.       (multiple-value-bind (arrow-x arrow-y arrow-width arrow-height)
  1017.           (scrollbar-less-arrow-geometry scroller)
  1018.         
  1019.         (using-gcontext
  1020.           (gc :drawable       scroller
  1021.           :function       boole-xor
  1022.           :foreground     highlight-pixel)
  1023.           
  1024.           ;; Highlight arrow
  1025.           (draw-rectangle
  1026.         (svref regions *elevator-region*) gc
  1027.         arrow-x arrow-y arrow-width arrow-height :fill-p)      
  1028.  
  1029.           ;; Force pointer to stay within arrow window
  1030.           (grab-pointer scroller #.(make-event-mask :button-press :button-release)
  1031.                 :confine-to (svref regions *less-arrow-region*))
  1032.             
  1033.           (if (catch :release (not (process-next-event display *scroller-click-timeout*)))
  1034.           
  1035.           ;; Perform continuous scrolling...
  1036.           (progn
  1037.             ;; Set timer for update
  1038.             (when (and (numberp update-delay) (plusp update-delay))
  1039.               (add-timer scroller :update-delay update-delay))
  1040.             
  1041.             ;; Increment until release event
  1042.             (apply-callback scroller :begin-continuous)
  1043.             (catch :release
  1044.               (loop
  1045.             (scroller-increment-value scroller (- increment))
  1046.             (do () ((not (process-next-event display *scroller-hold-timeout*))))))
  1047.             (apply-callback scroller :end-continuous))
  1048.           
  1049.           ;; Single click -- increment value.
  1050.           (scroller-increment-value scroller (- increment)))    
  1051.         
  1052.           ;; Report final value, if necessary                       
  1053.           (unless (eql 0 update-delay)
  1054.         (delete-timer scroller :update-delay)
  1055.         (apply-callback scroller :new-value value))
  1056.  
  1057.           ;; Release grab
  1058.           (ungrab-pointer display)
  1059.           
  1060.           ;; Unhighlight arrow
  1061.           (draw-rectangle
  1062.         (svref regions *elevator-region*) gc
  1063.         arrow-x arrow-y arrow-width arrow-height :fill-p))))))
  1064.  
  1065.     (press-more-arrow (scroller)
  1066.       (with-slots (display regions value maximum increment update-delay foreground orientation) scroller
  1067.     (let
  1068.       ((highlight-pixel (logxor foreground (contact-current-background-pixel scroller))))
  1069.  
  1070.       (multiple-value-bind (arrow-x arrow-y arrow-width arrow-height)
  1071.           (scrollbar-more-arrow-geometry scroller)
  1072.         
  1073.         (using-gcontext
  1074.           (gc :drawable       scroller
  1075.           :function       boole-xor
  1076.           :foreground     highlight-pixel)
  1077.           
  1078.           ;; Highlight arrow
  1079.           (draw-rectangle
  1080.         (svref regions *elevator-region*) gc
  1081.         arrow-x arrow-y arrow-width arrow-height :fill-p)      
  1082.  
  1083.           ;; Force pointer to stay within arrow window
  1084.           (grab-pointer scroller #.(make-event-mask :button-press :button-release)
  1085.                 :confine-to (svref regions *more-arrow-region*))
  1086.             
  1087.           (if (catch :release (not (process-next-event display *scroller-click-timeout*)))
  1088.           
  1089.           ;; Perform continuous scrolling...
  1090.           (progn
  1091.             ;; Set timer for update
  1092.             (when (and (numberp update-delay) (plusp update-delay))
  1093.               (add-timer scroller :update-delay update-delay))
  1094.             
  1095.             ;; Increment until release event
  1096.             (apply-callback scroller :begin-continuous)
  1097.             (catch :release
  1098.               (loop
  1099.             (scroller-increment-value scroller increment)
  1100.             (do () ((not (process-next-event display *scroller-hold-timeout*))))))
  1101.             (apply-callback scroller :end-continuous))
  1102.           
  1103.           ;; Single click -- increment value.
  1104.           (scroller-increment-value scroller increment))
  1105.           
  1106.           ;; Report final value, if necessary                       
  1107.           (unless (eql 0 update-delay)
  1108.         (delete-timer scroller :update-delay)
  1109.         (apply-callback scroller :new-value value))
  1110.  
  1111.           ;; Release grab
  1112.           (ungrab-pointer display)
  1113.           
  1114.           ;; Unhighlight arrow
  1115.           (draw-rectangle
  1116.         (svref regions *elevator-region*) gc
  1117.         arrow-x arrow-y arrow-width arrow-height :fill-p))))))
  1118.     
  1119.     (press-max-anchor (scroller)
  1120.       (with-slots (display regions foreground maximum value) scroller
  1121.     ;; Highlight max anchor
  1122.     (let
  1123.       ((max-anchor     (svref regions *max-anchor-region*))
  1124.        (highlight-size (scrollbar-anchor-width
  1125.                  (getf *scrollbar-dimensions* (contact-scale scroller)))))
  1126.       
  1127.       ;; This rectangle size is "too big", but we let the server clip it
  1128.       (using-gcontext (gc :drawable scroller :foreground foreground)
  1129.         (draw-rectangle
  1130.           max-anchor gc
  1131.           0 0 highlight-size highlight-size
  1132.           :fill-p))
  1133.       
  1134.       ;; Wait for release event
  1135.       (catch :release
  1136.         (loop (process-next-event display)))
  1137.       
  1138.       ;; Unhighlight max anchor
  1139.       (clear-area max-anchor)
  1140.       
  1141.       ;; Go to maximum position
  1142.       (unless (= value maximum)
  1143.         (setf (scale-value scroller) maximum)
  1144.         (apply-callback scroller :new-value maximum)))))
  1145.     
  1146.     (press-min-anchor (scroller)
  1147.       (with-slots (display regions foreground minimum value) scroller
  1148.     ;; Highlight min anchor
  1149.     (let
  1150.       ((min-anchor     (svref regions *min-anchor-region*))
  1151.        (highlight-size (scrollbar-anchor-width
  1152.                  (getf *scrollbar-dimensions* (contact-scale scroller)))))
  1153.       
  1154.       ;; This rectangle size is "too big", but we let the server clip it
  1155.       (using-gcontext (gc :drawable scroller :foreground foreground)
  1156.         (draw-rectangle
  1157.           min-anchor gc
  1158.           0 0 highlight-size highlight-size
  1159.           :fill-p))
  1160.       
  1161.       ;; Wait for release event
  1162.       (catch :release
  1163.         (loop (process-next-event display)))
  1164.       
  1165.       ;; Unhighlight min anchor
  1166.       (clear-area min-anchor)
  1167.       
  1168.       ;; Go to minimum position
  1169.       (unless (= value minimum)
  1170.         (setf (scale-value scroller) minimum)
  1171.         (apply-callback scroller :new-value minimum))))))
  1172.  
  1173.     ;; Initialize press-handlers dispatch vector
  1174.     (setf (svref press-handlers *elevator-region*)   nil)    ; should never be used!!
  1175.     (setf (svref press-handlers *min-anchor-region*) #'press-min-anchor)
  1176.     (setf (svref press-handlers *max-anchor-region*) #'press-max-anchor)
  1177.     (setf (svref press-handlers *less-arrow-region*) #'press-less-arrow)
  1178.     (setf (svref press-handlers *drag-area-region*)  #'press-drag-area)
  1179.     (setf (svref press-handlers *more-arrow-region*) #'press-more-arrow)
  1180.     (setf (svref press-handlers *cable-region*)      #'press-cable)
  1181.  
  1182.     ;; Define press action function
  1183.     (defun scroller-handle-press (scroller)
  1184.       (let ((*scroller-pressed-p* t))
  1185.     (declare (special *scroller-pressed-p*))
  1186.     (funcall (svref press-handlers (find-region scroller)) scroller)))))
  1187.  
  1188. (defun scroller-handle-release (scroller)
  1189.   (declare (ignore scroller))
  1190.   (declare (special *scroller-pressed-p*))
  1191.   (when (boundp '*scroller-pressed-p*)
  1192.     (throw :release nil)))
  1193.  
  1194. (defun scroller-handle-motion (scroller)
  1195.   (declare (special *previous-position* *drag-motion*))
  1196.   (when (boundp '*drag-motion*)
  1197.     (with-slots (orientation) (the scroller scroller)   
  1198.       (with-event (state x y)
  1199.     (multiple-value-bind (ptr-x ptr-y)
  1200.         ;; Is :button-1 still down?
  1201.         (if (plusp (logand state #.(make-state-mask :button-1)))
  1202.         
  1203.         ;; Yes, query current pointer position
  1204.         (query-pointer scroller)
  1205.         
  1206.         ;; No, use final x,y returned for button transition
  1207.         (values x y))
  1208.       
  1209.       (let* ((new-position (if (eq :vertical orientation) ptr-y ptr-x))
  1210.          (increment    (scroller-pixel-value scroller (- new-position *previous-position*))))
  1211.         (unless (zerop increment)
  1212.           (scroller-increment-value scroller increment)
  1213.           (setf *previous-position* new-position))))))))
  1214.  
  1215.  
  1216. (defun scroller-report-new-value (scroller)
  1217.   (with-slots (value) (the scroller scroller)
  1218.     (apply-callback scroller :new-value value)))
  1219.  
  1220. (defun scroller-increment-value (scroller increment)
  1221.   (with-slots (value minimum maximum update-delay) (the scroller scroller)    
  1222.     (let*
  1223.       ((new-value (+ value increment))
  1224.        (adjusted  (min (max  (or (apply-callback scroller :adjust-value new-value)
  1225.                  new-value)
  1226.                  minimum)
  1227.                maximum)))
  1228.       
  1229.       (unless (= adjusted value)
  1230.     (setf (scale-value scroller) adjusted)
  1231.     (when (eql 0 update-delay)
  1232.       (apply-callback scroller :new-value adjusted))))))
  1233.  
  1234.  
  1235. (defun scrollbar-cable-warp (scroller pane-increment current-x current-y min-position max-position)
  1236.   (with-slots (orientation) (the scroller scroller)
  1237.     (let*
  1238.       ((current-position
  1239.      (if (eq :vertical orientation) current-y current-x))
  1240.        
  1241.        (new-pointer-position
  1242.      (if (plusp pane-increment)
  1243.          (when (< current-position (setf min-position
  1244.                          (+ (scroller-value-position scroller)
  1245.                         (scrollbar-elevator-size  scroller))))
  1246.            (1+ min-position))
  1247.          
  1248.          (when (> current-position (setf max-position
  1249.                          (scroller-value-position scroller)))
  1250.            (1- max-position)))))
  1251.       
  1252.       (when new-pointer-position    
  1253.     (if (eq :vertical orientation)
  1254.         (setf current-y new-pointer-position)
  1255.         (setf current-x new-pointer-position))          
  1256.     (warp-pointer scroller current-x current-y))
  1257.       
  1258.       (values current-x current-y))))
  1259.  
  1260.  
  1261. (defun scroller-value-position (scroller)
  1262.   (with-slots (width height orientation value minimum maximum) (the scroller scroller)
  1263.     (let*
  1264.       ((dimensions       (getf *scrollbar-dimensions* (contact-scale scroller))) 
  1265.        (margin           (scrollbar-margin dimensions)) 
  1266.        (anchor-height    (scrollbar-anchor-height dimensions))
  1267.        (range            (- maximum minimum)))
  1268.       
  1269.       (+ anchor-height
  1270.      margin
  1271.      (if (zerop range) 0         
  1272.          (pixel-round
  1273.            (* (- value minimum)
  1274.           
  1275.           ;; Pixels per value unit 
  1276.           (/ (- (if (eq orientation :vertical) height width)
  1277.             anchor-height margin
  1278.             (* (scrollbar-anchor-width dimensions)
  1279.                (if (scrollbar-abbreviated-p scroller) 2 3))
  1280.             2
  1281.             margin anchor-height)
  1282.              range))))))))
  1283.  
  1284.  
  1285. (defun scroller-pixel-value (scroller pixels)
  1286.   (with-slots (width height orientation minimum maximum increment) (the scroller scroller)
  1287.     (let*
  1288.       ((dimensions       (getf *scrollbar-dimensions* (contact-scale scroller))) 
  1289.        (margin           (scrollbar-margin dimensions)) 
  1290.        (anchor-height    (scrollbar-anchor-height dimensions)))
  1291.  
  1292.       ;; pixels times value-units-per-pixel, rounded to nearest multiple of increment
  1293.       (* (pixel-round
  1294.        (/ (* pixels (- maximum minimum))
  1295.           (- (if (eq orientation :vertical) height width)
  1296.          anchor-height margin
  1297.          (* (scrollbar-anchor-width dimensions)
  1298.             (if (scrollbar-abbreviated-p scroller) 2 3))
  1299.          2
  1300.          margin anchor-height))
  1301.        increment)
  1302.      increment))))
  1303.  
  1304.  
  1305. (defun scroller-indicator-position (scroller &optional size)
  1306.   (setf size (or size (scroller-indicator-size scroller)))
  1307.   
  1308.   (with-slots (width height orientation value minimum maximum) (the scroller scroller)
  1309.     (let*
  1310.       ((dimensions       (getf *scrollbar-dimensions* (contact-scale scroller))) 
  1311.        (margin           (scrollbar-margin dimensions)) 
  1312.        (anchor-height    (scrollbar-anchor-height dimensions))
  1313.        (range            (- maximum minimum)))
  1314.       
  1315.       (+ anchor-height
  1316.      margin
  1317.      (if (zerop range) 0         
  1318.          (pixel-round
  1319.            (* (- value minimum)
  1320.           
  1321.           ;; Pixels per value unit for indicator position
  1322.           (/ (- (if (eq orientation :vertical) height width)
  1323.             anchor-height margin
  1324.             size            
  1325.             margin anchor-height)
  1326.              range))))))))
  1327.  
  1328. (defun scroller-indicator-size (scroller)
  1329.   (with-slots (width height orientation minimum maximum indicator-size) (the scroller scroller)
  1330.     (let*
  1331.       ((dimensions       (getf *scrollbar-dimensions* (contact-scale scroller))) 
  1332.        (margin           (scrollbar-margin dimensions)) 
  1333.        (anchor-height    (scrollbar-anchor-height dimensions))
  1334.        (range            (- maximum minimum)))
  1335.       
  1336.       (pixel-round
  1337.     (*
  1338.       (min (true-indicator-size indicator-size) range)     ; "clip" displayed size to cable range 
  1339.       (if (zerop range) 0         
  1340.           ;; Pixels per value unit for indicator size
  1341.           (/ (- (if (eq orientation :vertical) height width)
  1342.             anchor-height margin            
  1343.             margin anchor-height)
  1344.          range)))))))
  1345.  
  1346.